Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue54/Persist/tiUtils.pas

Pascal/Delphi Source File | 2000-01-21 | 6.7 KB | 220 lines

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  (c) TechInsite Pty. Ltd.
  PO Box 429, Abbotsford, Melbourne. 3067 Australia
  Phone: [phone]
  Fax:   [phone]
  Web:   www.techinsite.com.au
  EMail: [e-mail]

  Created: Jan 2000

  Notes: Utility functions

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit TIUtils ;

interface
uses

  Classes
  ,TypInfo
  ;

const

  // Type kinds for use with tiGetPropertyNames
  // All string type properties
  ctkString = [ tkChar, tkString, tkWChar, tkLString, tkWString ] ;
  // Integer type properties
  ctkInt    = [ tkInteger, tkInt64 ] ;
  // Float type properties
  ctkFloat  = [ tkFloat ] ;
  // All simple types (string, int, float)
  ctkSimple = ctkString + ctkInt + ctkFloat ;

type
  // Simple TypeKinds, as summary of the TTypeKinds available in TypInfo
  TtiTypeKind =  ( tiTKInteger, tiTKFloat , tiTKString ) ;

  // These are all the possibilities
  // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
  // tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
  // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray);

  // Count the number of fields in a string as delimited by psToken
  function  tiNumToken(         const pStrValue, pStrToken : string ) : integer ;
  // Extract the pIntNum(th) field from as string as delimited by psToken
  function  tiToken(            const pStrValue, pStrToken : string; const pIntNum : integer ) : string ;
  // Swap the pStrDel characters in a string with pStrIns
  function  tiStrTran(          pStrValue, pStrDel, pStrIns : string ) : string ;

  // Convert a propert from Delphis TTypeKind to TtiSimpleTypeKind
  // EG: Change tkInteger, tkInt64 and tkEnumeration to tkInteger
  function tiGetSimplePropType( pPersistent : TPersistent ; psPropName : string ) : TtiTypeKind ;
  // Read a TPersistent's published properties into a TStringList
  procedure tiGetPropertyNames( pPersistent : TObject ;
                                pSL : TStringList ;
                                pPropFilter : TTypeKinds = ctkSimple ) ;

implementation
uses
  SysUtils
  ;

// Seaches <sStr> and replaces <sDel> with <sIns>
// Case sensitive.
//------------------------------------------------------------------------------
function tiStrTran( pStrValue, pStrDel, pStrIns : string ) : string ;
var i : integer ;
    sToChange : string ;
begin
  result := '' ;
  sToChange := pStrValue ;
  i := pos( pStrDel, sToChange ) ;
  while i <> 0 do begin
    result := result + copy( sToChange, 1, i-1 ) + pStrIns ;
    delete( sToChange, 1, i+length( pStrDel )-1) ;
    i := pos( pStrDel, sToChange ) ;
  end ;
  result := result + sToChange ;
end ;

//------------------------------------------------------------------------------
function tiNumToken( const pStrValue, pStrToken : string ) : integer ;
var
  i, iCount : integer ;
  lsValue : string ;
begin
  iCount := 0 ;
  lsValue := pStrValue ;
  i := pos( pStrToken, lsValue ) ;
  while i <> 0 do begin
    delete( lsValue, i, length( pStrToken )) ;
    inc( iCount ) ;
    i := pos( pStrToken, lsValue ) ;
  end ;
  result := iCount + 1 ;
end ;

//------------------------------------------------------------------------------
function tiToken( const pStrValue, pStrToken : string; const pIntNum : integer ) : string ;
var
  i, iCount, iNumToken : integer ;
  lsValue : string ;
begin

  result := '' ;

  iNumToken := tiNumToken( pStrValue, pStrToken ) ;
  if pIntNum = 1 then begin
    if pos( pStrToken, pStrValue ) = 0 then result := pStrValue
    else result := copy( pStrValue, 1, pos( pStrToken, pStrValue )-1) ;
    end
  else if (iNumToken < pIntNum-1) or (pIntNum<1) then begin
    result := '' ;
    end
  else begin

    { Remove leading blocks }
    iCount := 1 ;
    lsValue := pStrValue ;
    i := pos( pStrToken, lsValue ) ;
    while (i<>0) and (iCount<pIntNum) do begin
      delete( lsValue, 1, i + length( pStrToken ) - 1 ) ;
      inc( iCount ) ;
      i := pos( pStrToken, lsValue ) ;
    end ;

    if (i=0) and (iCount=pIntNum) then result := lsValue
    else if (i=0) and (iCount<>pIntNum) then result := ''
    else result := copy( lsValue, 1, i-1) ;

  end ;
end ;

//------------------------------------------------------------------------------
function tiMixedCase( pStrValue : string ) : string ;
var iToken : integer ;
    i : integer ;
    sBuffer : string ;
begin
  iToken := tiNumToken( pStrValue, ' ' ) ;
  result := '' ;
  pStrValue := lowerCase( pStrValue ) ;
  for i := 1 to iToken do begin
    sBuffer := tiToken( pStrValue, ' ', i ) ;
    if result <> '' then result := result + ' ' ;
    result  := result +
               upperCase( copy( sBuffer, 1, 1 )) +
               copy( sBuffer, 2, length( sBuffer ) - 1 ) ;
  end ;
end ;

procedure tiGetPropertyNames( pPersistent : TObject ; pSL : TStringList ;
                              pPropFilter : TTypeKinds = ctkSimple ) ;
var
  lCount : integer ;
  lSize  : integer ;
  lList  : PPropList ;
  i : integer ;
  lPropFilter : TTypeKinds ;
begin
  Assert( pPersistent <> nil, 'pPersistent not assigned.' ) ;
  Assert( pSL <> nil, 'pSL not assigned.' ) ;
  lPropFilter := pPropFilter ;

  pSL.Clear ;

  lCount := GetPropList(pPersistent.ClassInfo, lPropFilter, nil);
  lSize := lCount * SizeOf(Pointer);
  GetMem(lList, lSize);
  try
    GetPropList(pPersistent.ClassInfo, lPropFilter, lList);
    for i := 0 to lcount - 1 do
      psl.add( lList[i].Name ) ;
  finally
    FreeMem( lList, lSize ) ;
  end ;

end ;

//  TTypeKind = ( tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
//                tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
//                tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray);
//------------------------------------------------------------------------------
function tiGetSimplePropType( pPersistent : TPersistent ; psPropName : string ) : TtiTypeKind ;
var
  lPropType : TTypeKind ;
begin

  try
    lPropType := PropType( pPersistent, psPropName ) ;
  except
    on e:exception do
      raise exception.create( 'Error in tiGetSimpleTypeKind ' +
                              'Message: ' + e.message ) ;
  end ;

  case lPropType of
  tkInteger,
  tkInt64,
  tkEnumeration : result := tiTKInteger ;

  tkFloat       : result := tiTKFloat ;

  tkString,
  tkChar,
  tkWChar,
  tkLString,
  tkWString     : result := tiTKString ;

  else
    raise exception.create( 'Invalid property type passed to ' +
                            'tiGetSimpleTypeKind' ) ;
  end ;

end;

end.